home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_perl.idb / usr / freeware / lib / perl5 / 5.00502 / B / Stackobj.pm.z / Stackobj.pm
Encoding:
Perl POD Document  |  1998-10-28  |  6.6 KB  |  302 lines
  1. #      Stackobj.pm
  2. #
  3. #      Copyright (c) 1996 Malcolm Beattie
  4. #
  5. #      You may distribute under the terms of either the GNU General Public
  6. #      License or the Artistic License, as specified in the README file.
  7. #
  8. package B::Stackobj;
  9. use Exporter ();
  10. @ISA = qw(Exporter);
  11. @EXPORT_OK = qw(set_callback T_UNKNOWN T_DOUBLE T_INT
  12.         VALID_INT VALID_DOUBLE VALID_SV REGISTER TEMPORARY);
  13. %EXPORT_TAGS = (types => [qw(T_UNKNOWN T_DOUBLE T_INT)],
  14.         flags => [qw(VALID_INT VALID_DOUBLE VALID_SV
  15.                  REGISTER TEMPORARY)]);
  16.  
  17. use Carp qw(confess);
  18. use strict;
  19. use B qw(class);
  20.  
  21. # Perl internal constants that I should probably define elsewhere.
  22. sub SVf_IOK () { 0x10000 }
  23. sub SVf_NOK () { 0x20000 }
  24.  
  25. # Types
  26. sub T_UNKNOWN () { 0 }
  27. sub T_DOUBLE ()  { 1 }
  28. sub T_INT ()     { 2 }
  29.  
  30. # Flags
  31. sub VALID_INT ()    { 0x01 }
  32. sub VALID_DOUBLE ()    { 0x02 }
  33. sub VALID_SV ()        { 0x04 }
  34. sub REGISTER ()        { 0x08 } # no implicit write-back when calling subs
  35. sub TEMPORARY ()    { 0x10 } # no implicit write-back needed at all
  36.  
  37. #
  38. # Callback for runtime code generation
  39. #
  40. my $runtime_callback = sub { confess "set_callback not yet called" };
  41. sub set_callback (&) { $runtime_callback = shift }
  42. sub runtime { &$runtime_callback(@_) }
  43.  
  44. #
  45. # Methods
  46. #
  47.  
  48. sub write_back { confess "stack object does not implement write_back" }
  49.  
  50. sub invalidate { shift->{flags} &= ~(VALID_INT | VALID_DOUBLE) }
  51.  
  52. sub as_sv {
  53.     my $obj = shift;
  54.     if (!($obj->{flags} & VALID_SV)) {
  55.     $obj->write_back;
  56.     $obj->{flags} |= VALID_SV;
  57.     }
  58.     return $obj->{sv};
  59. }
  60.  
  61. sub as_int {
  62.     my $obj = shift;
  63.     if (!($obj->{flags} & VALID_INT)) {
  64.     $obj->load_int;
  65.     $obj->{flags} |= VALID_INT;
  66.     }
  67.     return $obj->{iv};
  68. }
  69.  
  70. sub as_double {
  71.     my $obj = shift;
  72.     if (!($obj->{flags} & VALID_DOUBLE)) {
  73.     $obj->load_double;
  74.     $obj->{flags} |= VALID_DOUBLE;
  75.     }
  76.     return $obj->{nv};
  77. }
  78.  
  79. sub as_numeric {
  80.     my $obj = shift;
  81.     return $obj->{type} == T_INT ? $obj->as_int : $obj->as_double;
  82. }
  83.  
  84. #
  85. # Debugging methods
  86. #
  87. sub peek {
  88.     my $obj = shift;
  89.     my $type = $obj->{type};
  90.     my $flags = $obj->{flags};
  91.     my @flags;
  92.     if ($type == T_UNKNOWN) {
  93.     $type = "T_UNKNOWN";
  94.     } elsif ($type == T_INT) {
  95.     $type = "T_INT";
  96.     } elsif ($type == T_DOUBLE) {
  97.     $type = "T_DOUBLE";
  98.     } else {
  99.     $type = "(illegal type $type)";
  100.     }
  101.     push(@flags, "VALID_INT") if $flags & VALID_INT;
  102.     push(@flags, "VALID_DOUBLE") if $flags & VALID_DOUBLE;
  103.     push(@flags, "VALID_SV") if $flags & VALID_SV;
  104.     push(@flags, "REGISTER") if $flags & REGISTER;
  105.     push(@flags, "TEMPORARY") if $flags & TEMPORARY;
  106.     @flags = ("none") unless @flags;
  107.     return sprintf("%s type=$type flags=%s sv=$obj->{sv}",
  108.            class($obj), join("|", @flags));
  109. }
  110.  
  111. sub minipeek {
  112.     my $obj = shift;
  113.     my $type = $obj->{type};
  114.     my $flags = $obj->{flags};
  115.     if ($type == T_INT || $flags & VALID_INT) {
  116.     return $obj->{iv};
  117.     } elsif ($type == T_DOUBLE || $flags & VALID_DOUBLE) {
  118.     return $obj->{nv};
  119.     } else {
  120.     return $obj->{sv};
  121.     }
  122. }
  123.  
  124. #
  125. # Caller needs to ensure that set_int, set_double,
  126. # set_numeric and set_sv are only invoked on legal lvalues.
  127. #
  128. sub set_int {
  129.     my ($obj, $expr) = @_;
  130.     runtime("$obj->{iv} = $expr;");
  131.     $obj->{flags} &= ~(VALID_SV | VALID_DOUBLE);
  132.     $obj->{flags} |= VALID_INT;
  133. }
  134.  
  135. sub set_double {
  136.     my ($obj, $expr) = @_;
  137.     runtime("$obj->{nv} = $expr;");
  138.     $obj->{flags} &= ~(VALID_SV | VALID_INT);
  139.     $obj->{flags} |= VALID_DOUBLE;
  140. }
  141.  
  142. sub set_numeric {
  143.     my ($obj, $expr) = @_;
  144.     if ($obj->{type} == T_INT) {
  145.     $obj->set_int($expr);
  146.     } else {
  147.     $obj->set_double($expr);
  148.     }
  149. }
  150.  
  151. sub set_sv {
  152.     my ($obj, $expr) = @_;
  153.     runtime("SvSetSV($obj->{sv}, $expr);");
  154.     $obj->invalidate;
  155.     $obj->{flags} |= VALID_SV;
  156. }
  157.  
  158. #
  159. # Stackobj::Padsv
  160. #
  161.  
  162. @B::Stackobj::Padsv::ISA = 'B::Stackobj';
  163. sub B::Stackobj::Padsv::new {
  164.     my ($class, $type, $extra_flags, $ix, $iname, $dname) = @_;
  165.     bless {
  166.     type => $type,
  167.     flags => VALID_SV | $extra_flags,
  168.     sv => "PL_curpad[$ix]",
  169.     iv => "$iname",
  170.     nv => "$dname"
  171.     }, $class;
  172. }
  173.  
  174. sub B::Stackobj::Padsv::load_int {
  175.     my $obj = shift;
  176.     if ($obj->{flags} & VALID_DOUBLE) {
  177.     runtime("$obj->{iv} = $obj->{nv};");
  178.     } else {
  179.     runtime("$obj->{iv} = SvIV($obj->{sv});");
  180.     }
  181.     $obj->{flags} |= VALID_INT;
  182. }
  183.  
  184. sub B::Stackobj::Padsv::load_double {
  185.     my $obj = shift;
  186.     $obj->write_back;
  187.     runtime("$obj->{nv} = SvNV($obj->{sv});");
  188.     $obj->{flags} |= VALID_DOUBLE;
  189. }
  190.  
  191. sub B::Stackobj::Padsv::write_back {
  192.     my $obj = shift;
  193.     my $flags = $obj->{flags};
  194.     return if $flags & VALID_SV;
  195.     if ($flags & VALID_INT) {
  196.     runtime("sv_setiv($obj->{sv}, $obj->{iv});");
  197.     } elsif ($flags & VALID_DOUBLE) {
  198.     runtime("sv_setnv($obj->{sv}, $obj->{nv});");
  199.     } else {
  200.     confess "write_back failed for lexical @{[$obj->peek]}\n";
  201.     }
  202.     $obj->{flags} |= VALID_SV;
  203. }
  204.  
  205. #
  206. # Stackobj::Const
  207. #
  208.  
  209. @B::Stackobj::Const::ISA = 'B::Stackobj';
  210. sub B::Stackobj::Const::new {
  211.     my ($class, $sv) = @_;
  212.     my $obj = bless {
  213.     flags => 0,
  214.     sv => $sv    # holds the SV object until write_back happens
  215.     }, $class;
  216.     my $svflags = $sv->FLAGS;
  217.     if ($svflags & SVf_IOK) {
  218.     $obj->{flags} = VALID_INT|VALID_DOUBLE;
  219.     $obj->{type} = T_INT;
  220.     $obj->{nv} = $obj->{iv} = $sv->IV;
  221.     } elsif ($svflags & SVf_NOK) {
  222.     $obj->{flags} = VALID_INT|VALID_DOUBLE;
  223.     $obj->{type} = T_DOUBLE;
  224.     $obj->{iv} = $obj->{nv} = $sv->NV;
  225.     } else {
  226.     $obj->{type} = T_UNKNOWN;
  227.     }
  228.     return $obj;
  229. }
  230.  
  231. sub B::Stackobj::Const::write_back {
  232.     my $obj = shift;
  233.     return if $obj->{flags} & VALID_SV;
  234.     # Save the SV object and replace $obj->{sv} by its C source code name
  235.     $obj->{sv} = $obj->{sv}->save;
  236.     $obj->{flags} |= VALID_SV|VALID_INT|VALID_DOUBLE;
  237. }
  238.  
  239. sub B::Stackobj::Const::load_int {
  240.     my $obj = shift;
  241.     $obj->{iv} = int($obj->{sv}->PV);
  242.     $obj->{flags} |= VALID_INT;
  243. }
  244.  
  245. sub B::Stackobj::Const::load_double {
  246.     my $obj = shift;
  247.     $obj->{nv} = $obj->{sv}->PV + 0.0;
  248.     $obj->{flags} |= VALID_DOUBLE;
  249. }
  250.  
  251. sub B::Stackobj::Const::invalidate {}
  252.  
  253. #
  254. # Stackobj::Bool
  255. #
  256.  
  257. @B::Stackobj::Bool::ISA = 'B::Stackobj';
  258. sub B::Stackobj::Bool::new {
  259.     my ($class, $preg) = @_;
  260.     my $obj = bless {
  261.     type => T_INT,
  262.     flags => VALID_INT|VALID_DOUBLE,
  263.     iv => $$preg,
  264.     nv => $$preg,
  265.     preg => $preg        # this holds our ref to the pseudo-reg
  266.     }, $class;
  267.     return $obj;
  268. }
  269.  
  270. sub B::Stackobj::Bool::write_back {
  271.     my $obj = shift;
  272.     return if $obj->{flags} & VALID_SV;
  273.     $obj->{sv} = "($obj->{iv} ? &PL_sv_yes : &PL_sv_no)";
  274.     $obj->{flags} |= VALID_SV;
  275. }
  276.  
  277. # XXX Might want to handle as_double/set_double/load_double?
  278.  
  279. sub B::Stackobj::Bool::invalidate {}
  280.  
  281. 1;
  282.  
  283. __END__
  284.  
  285. =head1 NAME
  286.  
  287. B::Stackobj - Helper module for CC backend
  288.  
  289. =head1 SYNOPSIS
  290.  
  291.     use B::Stackobj;
  292.  
  293. =head1 DESCRIPTION
  294.  
  295. See F<ext/B/README>.
  296.  
  297. =head1 AUTHOR
  298.  
  299. Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
  300.  
  301. =cut
  302.